(defproto color-test-proto '(pause stop) () display-window-proto2)

(defmeth color-test-proto :colors (low hi num)
  (send self :slot-value 'pause 180)
  (let* ((vals (rseq hi low num))
         (pause (send self :slot-value 'pause))
         (val)
         )
    (dotimes (i num)
             (dotimes (j num) 
                      (dotimes (k num)
                               (setf a (select vals i))
                               (setf b (select vals j))
                               (setf c (select vals k))
                               (send self :set-color a b c) 
                               (pause pause)
                               (when (send self :slot-value 'stop)
                                     (format t "(~d ~d ~d)~%"a b c)
                                     (send self :slot-value 'stop nil)
                                     (loop (unless (send self :slot-value 'stop) 
                                                   (return))))
                               )))))



(defmeth color-test-proto :set-color (a b c)
  (apply #'make-color 'pink  (list a b c))
  (send self :flush-window)
  (send self :redraw)
  )
                      
(defmeth color-test-proto :do-click (x y m1 m2)
  (send self :slot-value 'stop (not (send self :slot-value 'stop))))



(defmeth color-test-proto :do-key (c m1 m2)
  (when m1 (send self :slot-value 'pause (+ 30 (send self slot-value ':pause)))
        (send self :slot-value 'pause 
              (if (> (send self :slot-value 'pause) 30) 
                  (- (send self :slot-value 'pause) 30) 30))))

(defun color-patch (&optional (a 1) (b 1) (c 1))
  ;(mapcar #'(lambda (color) 
  ;            (when (not (<= 0 color 1)) 
  ;                  (error-message "Colors must be between 0 and 1, inclusive")
  ;                  (top-level)))
  ;        (list a b c))
  (setf *color-patch* 
        (send color-test-proto :new 
              :size '(200 200) 
              :location (floor (/ (- (screen-size) '(200 200)) 2))
              :title (format nil "Color:   (~d   ~d   ~d)" a b c)))
  (send *color-patch* :top-most t)
  (send (send *color-patch* :menu ) :remove)
  (send *color-patch* :use-color t)
  (send *color-patch* :set-color a b c))
        
;(color-patch 0 1 5)
